Nous souhaitons classifier un article du monde selon son contenu, Nous possèdons pour cela un jeu de données avec la catégorie et le contenu de 10k articles.

Pour mener notre tâche à bien nous allons effectuer un prétraitement des données textuelles par la transformation de données (textuelles) non structurées en un format de données structuré.

Et ce dans l’objectif d’appliquer des algorithmes de classifications, cela inclut la pondération et la sélection des variables(des mots).

Concrètement, il s’agit de la transformation d’un grand nombre de caractéristiques éparses en un nombre significativement plus petit de caractéristiques denses.

Nous utiliserons ainsi 3 algorithmes pour la classification dont un dans une version limitée à 25 variables explicatives.

Nous finirons par l’évaluation des résultats de la prédiction des classifications sur le jeu de test.

Import de la base de données & du jeu test

On utilise l’encodage UTF-8 car le monde est un journal français utilisant des caractères spéciaux. Le jeu de test est fournis, il a pour élément positif le fait d’être un article de type économie

data <- 
   read.csv("le_monde.csv", encoding="UTF-8", sep=";", comment.char="#")
test <- 
  read.csv("lignes_jeux_tests.csv")

transformation des données

Il est nécessaire de transformer ces données, nous n’avons qu’une unique variable explicative : le texte en entier de l’article. Cette unique variable explicative est inexploitable, nous souhaitons un “bag of words”.

Suppression des deux collones non utiles à la modélisation

data$date <- NULL
data$title <- NULL

Pour la gestion des manquants, on supprime les lignes avec des valeurs manquantes (normalement aucune supprimmé)

## integer(0)

On applique les bons types de variables

data$category <- as.factor(data$category)
data$content <- as.character(data$content)
str(data)

## 'data.frame':    10000 obs. of  2 variables:
##  $ category: Factor w/ 6 levels "culture","economie",..: 6 5 5 2 5 5 5 5 1 5 ...
##  $ content : chr  "  / L’international français Jérémy Ménez va rejoindre le club de Bordeaux en Ligue 1, en provenance du Milan A"| __truncated__ "  / Le cousin d’un des assassins du Père Jacques Hamel à Saint-Etienne-du-Rouvray, identifié comme étant Farid "| __truncated__ "  / Si le premier ministre Manuel Valls constate que « l’islam a trouvé sa place dans la République », « face à"| __truncated__ "  / Les épargnants français sont choyés. Lundi 1er août, le taux de rémunération du Livret A aurait théoriqueme"| __truncated__ ...

On retire les accents, en effet dans l’une des étapes suivantes où l’on retire les caractères qui ne sont pas des lettres, les lettres avec accents font des trous dans les mots, rendant un grand nombre de mots inexploitable.

On a besoin d’un objet de type corpus, on prend là ou sont les données, ici la collone V6. On affiche la première ligne

contenu <- Corpus(VectorSource(data$content))
contenu[1]$content

## [1] "  / L'international francais Jeremy Menez va rejoindre le club de Bordeaux en Ligue 1, en provenance du Milan AC, sous reserve de la traditionnelle visite medicale, a annonce le club aquitain dimanche. /  Menez est la troisieme recrue des Girondins apres le milieu de Monaco, Jeremy Toulalan, et l'attaquant guineen de Bastia, Francois Kamano. Bordeaux sort d'une pale saison et repart avec des ambitions nouvelles et l'entraineur Jocelyn Gourvennec, qui jouit d'une grosse cote grace a ses six saisons convaincantes a Guingamp. Age de 29 ans, Menez, qui compte 24 selections (2 buts) chez les Bleus -la derniere en 2013-, evoluait depuis deux ans au Milan AC, ou il lui restait un an de contrat, mais sa derniere saison a ete perturbee par des blessures. Forme a Sochaux, Menez fait partie de la fameuse generation 1987 championne d'Europe des U17 en 2004. Alors considere comme un des plus grands espoirs du foot francais, il avait par la suite rejoint Monaco de 2006 a 2008, puis la Roma pendant quatre saisons avant de revenir en France, au Paris-Saint-Germain en 2012. Son aventure parisienne, avec deux titres de champion a la cle, avait pris fin deux ans plus tard pour un retour en Italie, au Milan AC. Au sein de l'equipe lombarde il a realise sa meilleure saison (16 buts inscrits) en 2014-2015, avant d'etre perturbe par des blessures au dos la saison derniere qui l'ont prive de sept mois de competition, d'aout a janvier, pour ne disputer que 10 matchs (2 buts)."

On supprime les caracteres qui ne sont pas des lettres (cette étape posait problème avec les lettres à accent)

contenu <- tm_map(contenu, content_transformer(gsub), pattern = "[^a-zA-Z]", replacement = " ")

## Warning in tm_map.SimpleCorpus(contenu, content_transformer(gsub), pattern =
## "[^a-zA-Z]", : transformation drops documents

contenu[1]$content

## [1] "    L international francais Jeremy Menez va rejoindre le club de Bordeaux en Ligue    en provenance du Milan AC  sous reserve de la traditionnelle visite medicale  a annonce le club aquitain dimanche     Menez est la troisieme recrue des Girondins apres le milieu de Monaco  Jeremy Toulalan  et l attaquant guineen de Bastia  Francois Kamano  Bordeaux sort d une pale saison et repart avec des ambitions nouvelles et l entraineur Jocelyn Gourvennec  qui jouit d une grosse cote grace a ses six saisons convaincantes a Guingamp  Age de    ans  Menez  qui compte    selections    buts  chez les Bleus  la derniere en        evoluait depuis deux ans au Milan AC  ou il lui restait un an de contrat  mais sa derniere saison a ete perturbee par des blessures  Forme a Sochaux  Menez fait partie de la fameuse generation      championne d Europe des U   en       Alors considere comme un des plus grands espoirs du foot francais  il avait par la suite rejoint Monaco de      a       puis la Roma pendant quatre saisons avant de revenir en France  au Paris Saint Germain en       Son aventure parisienne  avec deux titres de champion a la cle  avait pris fin deux ans plus tard pour un retour en Italie  au Milan AC  Au sein de l equipe lombarde il a realise sa meilleure saison     buts inscrits  en            avant d etre perturbe par des blessures au dos la saison derniere qui l ont prive de sept mois de competition  d aout a janvier  pour ne disputer que    matchs    buts  "

On mets les majuscules en minuscules

contenu <- tm_map(contenu, content_transformer(tolower))

## Warning in tm_map.SimpleCorpus(contenu, content_transformer(tolower)):
## transformation drops documents

contenu[1]$content

## [1] "    l international francais jeremy menez va rejoindre le club de bordeaux en ligue    en provenance du milan ac  sous reserve de la traditionnelle visite medicale  a annonce le club aquitain dimanche     menez est la troisieme recrue des girondins apres le milieu de monaco  jeremy toulalan  et l attaquant guineen de bastia  francois kamano  bordeaux sort d une pale saison et repart avec des ambitions nouvelles et l entraineur jocelyn gourvennec  qui jouit d une grosse cote grace a ses six saisons convaincantes a guingamp  age de    ans  menez  qui compte    selections    buts  chez les bleus  la derniere en        evoluait depuis deux ans au milan ac  ou il lui restait un an de contrat  mais sa derniere saison a ete perturbee par des blessures  forme a sochaux  menez fait partie de la fameuse generation      championne d europe des u   en       alors considere comme un des plus grands espoirs du foot francais  il avait par la suite rejoint monaco de      a       puis la roma pendant quatre saisons avant de revenir en france  au paris saint germain en       son aventure parisienne  avec deux titres de champion a la cle  avait pris fin deux ans plus tard pour un retour en italie  au milan ac  au sein de l equipe lombarde il a realise sa meilleure saison     buts inscrits  en            avant d etre perturbe par des blessures au dos la saison derniere qui l ont prive de sept mois de competition  d aout a janvier  pour ne disputer que    matchs    buts  "

On retire les lettres isolés et les mots “vides” tel “quand, comme, hors …”

stopwords_fr <- stopwords("french")
stopwords_fr <- c(stopwords_fr, "a","b","c","d","e","f","g","h","i","j","k","l","m","n","o","p","q","r","s","t",
                   "u","v","w","x","y","z" )
contenu <- tm_map(contenu, removeWords , stopwords_fr)

## Warning in tm_map.SimpleCorpus(contenu, removeWords, stopwords_fr):
## transformation drops documents

contenu[1]$content

## [1] "     international francais jeremy menez va rejoindre  club  bordeaux  ligue     provenance  milan ac  sous reserve   traditionnelle visite medicale   annonce  club aquitain dimanche     menez   troisieme recrue  girondins apres  milieu  monaco  jeremy toulalan    attaquant guineen  bastia  francois kamano  bordeaux sort   pale saison  repart   ambitions nouvelles   entraineur jocelyn gourvennec   jouit   grosse cote grace   six saisons convaincantes  guingamp  age     ans  menez   compte    selections    buts  chez  bleus   derniere         evoluait depuis deux ans  milan ac     restait  an  contrat    derniere saison  ete perturbee   blessures  forme  sochaux  menez fait partie   fameuse generation      championne  europe            alors considere comme   plus grands espoirs  foot francais      suite rejoint monaco              puis  roma pendant quatre saisons avant  revenir  france   paris saint germain         aventure parisienne   deux titres  champion   cle   pris fin deux ans plus tard   retour  italie   milan ac   sein   equipe lombarde   realise  meilleure saison     buts inscrits              avant  etre perturbe   blessures  dos  saison derniere    prive  sept mois  competition   aout  janvier    disputer     matchs    buts  "

Racinisation (sans retirer le premier espace)

contenu <- tm_map(contenu, stemDocument, "french")

## Warning in tm_map.SimpleCorpus(contenu, stemDocument, "french"): transformation
## drops documents

#contenu[1]$content
contenu <- tm_map(contenu , stripWhitespace)

## Warning in tm_map.SimpleCorpus(contenu, stripWhitespace): transformation drops
## documents

contenu <- tm_map(contenu, content_transformer(gsub), pattern = "^\\s+", replacement = "")

## Warning in tm_map.SimpleCorpus(contenu, content_transformer(gsub), pattern = "^\
## \s+", : transformation drops documents

contenu[1]$content

## [1] "international franc jeremy men va rejoindr club bordeau ligu proven milan ac sous reserv traditionnel visit medical annonc club aquitain dimanch men troisiem recru girondin apre milieu monaco jeremy toulalan attaqu guineen basti francois kamano bordeau sort pal saison repart ambit nouvel entraineur jocelyn gourvennec jou gross cot grac six saison convainc guingamp age an men compt select but chez bleus dernier evolu depuis deux an milan ac rest an contrat dernier saison ete perturbe blessur form sochal men fait part fameux gener champion europ alor consider comm plus grand espoir foot franc suit rejoint monaco puis rom pend quatr saison avant reven franc paris saint germain aventur parisien deux titr champion cle pris fin deux an plus tard retour ital milan ac sein equip lombard realis meilleur saison but inscrit avant etre perturb blessur dos saison dernier priv sept mois competit aout janvi disput match but"

Vectorisation

Nous ne gardons que les mots avec 1000 occurences minimum

Le traitement de text effectué, on re-ajoute les données au tableau data pour comparer le texte de départ et le texte obtenu :

Le texte obtenu est correct.

Combien de fois les mots (variables) ont d’occurence dans le contenu des articles ?

summary(colSums(base_modele))

##    Min. 1st Qu.  Median    Mean 3rd Qu.    Max. 
##    1000    1228    1612    2229    2491   18858

On remarque une médiane à 1612 la haute valeur du maximum est surement dû à des mots vides (stop words) non retirer. Nous étudierons un modèle avec moins de variables (mots) dans une prochaine partie.

Testons notre hypothèse des stop words non retirer, en effet, il pourrait s’agir de mots apparaissant beaucoup dans une certaine catégorie d’articles. Regardons dans combien d’articles les mots sont référencés (sur 10k articles)

occurences <- apply(base_modele, 2, function(x) sum(x>0))
summary(occurences)

##    Min. 1st Qu.  Median    Mean 3rd Qu.    Max. 
##   364.0   871.5  1101.0  1392.7  1676.5  6237.0

Un maximum à 6237, soit 2/3 des documents. Nous verrons l’importance de ces mots dans le modèle lorsque nous réaliserons un modèle supervisé avec un maximum de 25 variables.

On construit alors notre modèle avec les catégories et les mots en variables.

base_modelisation = cbind.data.frame(data, base_modele)
base_modelisation = base_modelisation[,-2]
base_modelisation = base_modelisation[,-2]

#On prépare le jeu à 25 variables
#Somme <- colSums(base_modele)
#garder <- which(Somme > median(Somme))

Présentation des données

Analyse de la dispersion

Variables à expliquer : culture, economie, planete, politique, societe, sport.

439 Variables explicatives : les mots qui apparaissent plus de 1000 fois.

A noter que nous n’effectuons que les dernières partie d’un projet de Data Science, puisque les données nous ont été fournis.

Avant de réaliser des modèles de prédictions, détaillons le jeu de données transformé obtenu. Notre plus grande menace serait une corrélation globale de nos variables.

Visualisons graphiquement si nos variables sont très corrélés avec une heatmap :

Les variables sont très peu corrélés,

Pour complèter cela, on réalise une analyse en composante principale avec la catégorie en variable qualitative, ainsi en affichant les ellipse nous verrons les catégories qui s’opposent et quelles variables (les mots dans notre cas) sont les plus responsables des axes, autrement dit les plus importants.

#ces deux lignes sont marginales et ne permettent pas de ce centrer sur les individus.
base_modelisation_ACP <- base_modelisation[-c(8808,5857), ]
library(FactoMineR)
res.pca = PCA(base_modelisation_ACP, scale.unit=TRUE, ncp=5, quali.sup=1, graph=T)

#Essayons de dégager une tendance avec les catégories
#library("factoextra")
#fviz_pca_ind(res.pca, geom.ind = "point", col.ind = base_modelisation_ACP$category, 
 #            palette = c("#00AFBB", "#E7B800", "#FC4E07", "#33FF5E","#CC33FF", "#FFC233"  ),
  #           addEllipses = TRUE, ellipse.type = "confidence",
   #          legend.title = "Catégorie de l'article"
#)

plot.PCA(res.pca, axes=c(1, 2), choix="ind", habillage=1,label="var",graph.type = "ggplot")

Les deux premières dimensions ne rendent compte que de 10% de la variance, les graphiques sont inexploitables. Nous pouvons affirmer que les données sont très dispersés, leur non-corrélation est très forte.

Nuage de mots pour les catégories

Une fois la non-corrélation globale de nos variables assurés, Examinons graphiquement grâce à la librairie wordcloud les mots les plus fréquents par catégorie par un nuage de mots.

#Preparation des données pour le nuage des catégories
# on concatene tout le texte , on sélectionne la catégorie sport et spécicifie content_modif pour là où on prend le texte.
motSport <- paste(data[data$category=="sport",'content_modif'],collapse=' ') 
motSociete <- paste(data[data$category=="societe",'content_modif'],collapse=' ') 
motEconomie <- paste(data[data$category=="economie",'content_modif'],collapse=' ') 
motCulture <- paste(data[data$category=="culture",'content_modif'],collapse=' ') 
motPolitique <- paste(data[data$category=="politique",'content_modif'],collapse=' ') 
motPlanete <- paste(data[data$category=="planete",'content_modif'],collapse=' ') 
# on compte chaque mot, le motif entre guillemet veut dire qu'on coupe la #chainedecaractère quelque soit le nombre d'espaces entre les mots, decreasing en true car il faut montrer les most les plus fréquents , donc on met en décroissant (voir la doc de sort)
motsFreqSport <- data.frame(sort(table(strsplit(motSport,"\\s+")),decreasing = TRUE )) 
motsFreqSociete <- data.frame(sort(table(strsplit(motSociete,"\\s+")),decreasing = TRUE )) 
motsFreqEconomie <- data.frame(sort(table(strsplit(motEconomie,"\\s+")),decreasing = TRUE )) 
motsFreqCulture <- data.frame(sort(table(strsplit(motCulture,"\\s+")),decreasing = TRUE )) 
motsFreqPolitique <- data.frame(sort(table(strsplit(motPolitique,"\\s+")),decreasing = TRUE )) 
motsFreqPlanete <- data.frame(sort(table(strsplit(motPlanete,"\\s+")),decreasing = TRUE ))

Création des nuages de mots

Sport

wordcloud2(data = motsFreqSport[1:500,],minSize = 5, size = 3,shape = 'star',color = "random-light", backgroundColor = "grey")

Societe

wordcloud2(data = motsFreqSociete[1:500,],minSize = 5, size = 3,shape = 'star',color = "random-light", backgroundColor = "grey")

Economie

wordcloud2(data = motsFreqEconomie[1:500,],minSize = 5, size = 3,shape = 'star',color = "random-light", backgroundColor = "grey")

Culture

wordcloud2(data = motsFreqCulture[1:500,],minSize = 5, size = 3,shape = 'star',color = "random-light", backgroundColor = "grey")

Politique

wordcloud2(data = motsFreqPolitique[1:500,],minSize = 5, size = 3,shape = 'star',color = "random-light", backgroundColor = "grey")

Planete

wordcloud2(data = motsFreqPlanete[1:500,],minSize = 5, size = 3,shape = 'star',color = "random-light", backgroundColor = "grey")

De nombreux mots semblent spécifiques à une seule catégorie, nous devrions obtenir de bons indicateurs de prédiction.

Avant de passer à la partie suivante, supprimons les données que nous n’utiliserons plus

Premier modèle : CART

Introduction Modèle Supervisé

Apprentissage supervisé: expliquer/prédire une sortie Y à partir d’entrées X Nous devons éviter le sur-apprentissage, pour cela nous utiliserons la cross validation.

Modèle supervisé pouvant être utilisé : CART , Randomforest, un 3ème

On commence par construire un modèle d’apprentissage, composé de 80% des lignes de base_modelisation. Le jeu de test est quand à lui fourni.

nb_lignes <- sample(1:nrow(base_modelisation), nrow(base_modelisation)*0.80)
training <- base_modelisation[nb_lignes,]
testing <- base_modelisation[-nb_lignes,]

Construction de l’arbre

Notre premier modèle est un arbre de décision.

Le principe est que, tant qu’on a pas atteind la taille minimal de noeuds enfants on recherche un seuil qui permet de séparer le noeud parents en 2 noeuds enfants en maximisant notre critère de répartition/de fractionnement.

Notre critère de répartition est le GINI, il est par défaut dans la fonction rpart.

On prend un cp choisi arbitrairement.

tree <-rpart(category~. ,
             data = training,
             cp=0,
             minsplit = 10
            # ,control = rpart.control(minsplit = 10)
             )
visTree(tree)

Choix meilleur CP

On recherche le cp optimal.

plotcp(tree)

On affine la prédiction en choisissant l’arbre avec l’erreur de prédiction la plus basse

Meilleur <- which.min(tree$cptable[,"xerror"])
#Meilleur
cpBest <- tree$cptable[Meilleur, "CP"]
#cpBest
ArbreChoisi <- prune(tree, cp = cpBest)
visTree(ArbreChoisi)

#Mauvaise méthode puisque le meilleur cp change d'une exécution à l'autre du code
#Besttree <-rpart(category~. ,
#                 data = base_modelisation[nb_lignes,],
#                cp=8e-04,
#               minsplit = 10
                   # ,control = rpart.control(minsplit = 10)
                 
#              )
#visTree(Besttree)
#print(Besttree$cptable)

#attributes(Besttree)
#construction plot
#plot(Besttree)
#text(Besttree, use.n=T)

Deuxième modèle : Random Forest

Modélisation : Random Forest, algorithme de bagging

Le principe est de créer n arbres non corrélés entre eux puis faire voter chacun d’entre eux.

Pour faire varier un arbre on sélectionne une partie différente des données à chaque noeud et ne construisant des arbres que sur une partie des individus

Nous commencons avec les paramètres suivants : - mtry : 20 - nbtree: 100

Le paramètre mtry représente le nombre de variables échantillonnées de façon aléatoire comme candidats à chaque fractionnement. et nbtree est le nombre d’arbres générés.

#proximité entre les lignes calculés
 
                          
modele_rf = randomForest(category~. 
                         , data=training,
                         importance = T,
                         proximity=TRUE,
                         ntree = 100)
plot(modele_rf)

#print(modele_rf)
#modele_rf
#plot(modele_rf)

Troisième modèle

Modélisation :

NROW(training)

## [1] 8000

# Renvoie 8000 -> racine carré de 8000 = 89.44 -> on créé deux modèles avec un k=89 et un avec k=90 
library(dplyr)

## Warning: le package 'dplyr' a été compilé avec la version R 4.1.2

## 
## Attachement du package : 'dplyr'

## L'objet suivant est masqué depuis 'package:randomForest':
## 
##     combine

## Les objets suivants sont masqués depuis 'package:stats':
## 
##     filter, lag

## Les objets suivants sont masqués depuis 'package:base':
## 
##     intersect, setdiff, setequal, union

data_class <- base_modelisation
category_outcome <- data_class %>% select(category)
category_outcome <- category_outcome %>% mutate_if(is.character, as.factor)
category_outcome_train <- category_outcome[nb_lignes, ]
category_outcome_test <- category_outcome[-nb_lignes, ]
knn_89 <- knn(training[-1], testing[-1], cl=category_outcome_train, k=89)
knn_90 <- knn(training[-1], testing[-1], cl=category_outcome_train, k=90)
ACC_89 <- 100 * sum(category_outcome_test == knn_89)/NROW(category_outcome_test)
ACC_90 <- 100 * sum(category_outcome_test == knn_90)/NROW(category_outcome_test)
confusionMatrix(table(knn_89 ,category_outcome_test))

## Confusion Matrix and Statistics
## 
##            category_outcome_test
## knn_89      culture economie planete politique societe sport
##   culture       442      276     101       163     336   146
##   economie        7       79      18        18      22     4
##   planete         0        0       5         0       0     0
##   politique       2        8       6        71      30     2
##   societe         4       10      13        13     154     8
##   sport           1        1       0         0       0    60
## 
## Overall Statistics
##                                           
##                Accuracy : 0.4055          
##                  95% CI : (0.3839, 0.4274)
##     No Information Rate : 0.271           
##     P-Value [Acc > NIR] : < 2.2e-16       
##                                           
##                   Kappa : 0.2382          
##                                           
##  Mcnemar's Test P-Value : NA              
## 
## Statistics by Class:
## 
##                      Class: culture Class: economie Class: planete
## Sensitivity                  0.9693          0.2112        0.03497
## Specificity                  0.3381          0.9576        1.00000
## Pos Pred Value               0.3019          0.5338        1.00000
## Neg Pred Value               0.9739          0.8407        0.93083
## Prevalence                   0.2280          0.1870        0.07150
## Detection Rate               0.2210          0.0395        0.00250
## Detection Prevalence         0.7320          0.0740        0.00250
## Balanced Accuracy            0.6537          0.5844        0.51748
##                      Class: politique Class: societe Class: sport
## Sensitivity                    0.2679         0.2841       0.2727
## Specificity                    0.9723         0.9671       0.9989
## Pos Pred Value                 0.5966         0.7624       0.9677
## Neg Pred Value                 0.8969         0.7842       0.9174
## Prevalence                     0.1325         0.2710       0.1100
## Detection Rate                 0.0355         0.0770       0.0300
## Detection Prevalence           0.0595         0.1010       0.0310
## Balanced Accuracy              0.6201         0.6256       0.6358

confusionMatrix(table(knn_90 ,category_outcome_test))

## Confusion Matrix and Statistics
## 
##            category_outcome_test
## knn_90      culture economie planete politique societe sport
##   culture       443      276     101       164     336   146
##   economie        7       79      18        17      22     4
##   planete         0        0       4         0       0     0
##   politique       2        8       6        72      30     2
##   societe         4       10      14        12     154     8
##   sport           0        1       0         0       0    60
## 
## Overall Statistics
##                                           
##                Accuracy : 0.406           
##                  95% CI : (0.3844, 0.4279)
##     No Information Rate : 0.271           
##     P-Value [Acc > NIR] : < 2.2e-16       
##                                           
##                   Kappa : 0.2388          
##                                           
##  Mcnemar's Test P-Value : NA              
## 
## Statistics by Class:
## 
##                      Class: culture Class: economie Class: planete
## Sensitivity                  0.9715          0.2112        0.02797
## Specificity                  0.3374          0.9582        1.00000
## Pos Pred Value               0.3022          0.5374        1.00000
## Neg Pred Value               0.9757          0.8408        0.93036
## Prevalence                   0.2280          0.1870        0.07150
## Detection Rate               0.2215          0.0395        0.00200
## Detection Prevalence         0.7330          0.0735        0.00200
## Balanced Accuracy            0.6545          0.5847        0.51399
##                      Class: politique Class: societe Class: sport
## Sensitivity                    0.2717         0.2841       0.2727
## Specificity                    0.9723         0.9671       0.9994
## Pos Pred Value                 0.6000         0.7624       0.9836
## Neg Pred Value                 0.8973         0.7842       0.9175
## Prevalence                     0.1325         0.2710       0.1100
## Detection Rate                 0.0360         0.0770       0.0300
## Detection Prevalence           0.0600         0.1010       0.0305
## Balanced Accuracy              0.6220         0.6256       0.6361

Validation croisée

Améliorons nos modèles en évitant leur sur-apprentissage

Observons combien faut-il de temps pour calculer 100 arbres à mon ordinateur.

debut <- Sys.time()
cent = randomForest(category~. 
                         , data=training,
                         importance = T,
                         ntree = 100)
TempsCent <- Sys.time() - debut
print(paste("Pour cent arbres, il faut : ", TempsCent))

## [1] "Pour cent arbres, il faut :  1.99100250005722"

1 minute et 45 secondes !

En 3h, il y a 180 minutes, je peux donc générer 10 000 arbres en 3h. et en 20 minutes je peux en calculer 1000. Commençons par l’option à 1000 arbres.

Créons plusieurs modèle avec des mtry allant de 1 variables à toutes. En tout 50 configurations seront testés.

mtry_expand = expand.grid( .mtry = seq(from = 1, to = (ncol(training)-1), length.out = 50))
#length.out : premier multiplieur

On créé un grand nombre d’arbres par random forest, avec des configurations différentes du mtry, et grace à la librairie doSNOW on execute 4 fois le code afin d’obtenir une validation croisée.

require(caret)
require(doSNOW)

## Le chargement a nécessité le package : doSNOW

## Le chargement a nécessité le package : foreach

## Le chargement a nécessité le package : iterators

## Le chargement a nécessité le package : snow

#parametre du cv
cv.cntrl <- trainControl(method = "cv", 
                           number = 4, 
                           search = "grid")
  
 #on cree des instances , càd le nbre de fois que l'on execute le programme,
#mon processeur a 4 coeurs, je mets donc 4,
# il s'agira donc d'une validation croisée de degré 4.
# il s'agit de notre deuxième multiplieur
  cl <- makeCluster(4, 
                    type = "SOCK") 
  registerDoSNOW(cl)
  
  
  set.seed(1234)
 
  #méthode CART
 #   modele3 <- train(x = base_modelisation[nb_lignes,][,names(base_modelisation[nb_lignes,]) != 'category'],
  #                    y = base_modelisation[nb_lignes,]$category,
   #                   method = 'rpart', trControl = cv.cntrl, 
    #                  tuneGrid = mtry_expand, metric = "Accuracy")
  
  
  #méthode random forest 
    modele3 <- train(x = training[,names(training) != 'category'],
                      y = training$category, 
                      method = 'rf', trControl = cv.cntrl, 
                      tuneGrid = mtry_expand, metric = "Accuracy",
                      ntree = 5)
    #ntree est notre dernier multiplieur.
  
  # Processing is done, stop the cluster
  stopCluster(cl)
#On calcule ainsi length.out x nbre de clust x ntree = nbre d'arbres de notre modèle
  #                 50       x     4         x 5     = 1000

Quel est le meilleur paramètre pour mtry

modele3_mtry <- modele3$bestTune$mtry
#modele3_best <- modele3$results %>% filter(mtry==modele3_mtry)
#le meilleur mtry est de :
modele3_mtry

## [1] 313.8571

On affiche le modèle obtenu

plot(modele3)

plot(modele3$finalModel$predicted)

Prédiction

library(ROCR)
library(pROC)

## Type 'citation("pROC")' for a citation.

## 
## Attachement du package : 'pROC'

## Les objets suivants sont masqués depuis 'package:stats':
## 
##     cov, smooth, var

p3 <- predict(modele3, newdata=testing, type= "prob")
p3 <- p3[,1]

Matrice de confusion

MatriceConfu3 <- confusionMatrix(data = modele3$finalModel$predicted,
                                reference = training$category)
#labels <- c("Precision", "Recall", "F1", "Accuracy", "Kappa")
#confu3 <- MatriceConfu3$byClass[labels[1:3]]
#confu3 <- c(confu3, MatriceConfu3$overall[labels[4:5]])
MatriceConfu3

## Confusion Matrix and Statistics
## 
##            Reference
## Prediction  culture economie planete politique societe sport
##   culture      1172      195     160       116     407   182
##   economie      144      605     109       140     285    52
##   planete        35       93      90        47     116    10
##   politique      61      104      66       459     260    21
##   societe       159      217     123       229     953    59
##   sport          37       35      12        18      48   414
## 
## Overall Statistics
##                                          
##                Accuracy : 0.5106         
##                  95% CI : (0.499, 0.5222)
##     No Information Rate : 0.2861         
##     P-Value [Acc > NIR] : < 2.2e-16      
##                                          
##                   Kappa : 0.3881         
##                                          
##  Mcnemar's Test P-Value : < 2.2e-16      
## 
## Statistics by Class:
## 
##                      Class: culture Class: economie Class: planete
## Sensitivity                  0.7289         0.48439        0.16071
## Specificity                  0.8116         0.87801        0.95489
## Pos Pred Value               0.5251         0.45318        0.23018
## Neg Pred Value               0.9128         0.89081        0.93131
## Prevalence                   0.2223         0.17268        0.07742
## Detection Rate               0.1620         0.08364        0.01244
## Detection Prevalence         0.3086         0.18457        0.05406
## Balanced Accuracy            0.7702         0.68120        0.55780
##                      Class: politique Class: societe Class: sport
## Sensitivity                   0.45491         0.4606      0.56098
## Specificity                   0.91774         0.8476      0.97691
## Pos Pred Value                0.47271         0.5477      0.73404
## Neg Pred Value                0.91217         0.7968      0.95142
## Prevalence                    0.13950         0.2861      0.10203
## Detection Rate                0.06346         0.1318      0.05724
## Detection Prevalence          0.13425         0.2406      0.07798
## Balanced Accuracy             0.68632         0.6541      0.76894

AUC

length(testing$category)

## [1] 2000

auc(testing$category, p3)

## Warning in roc.default(response, predictor, auc = TRUE, ...): 'response'
## has more than two levels. Consider setting 'levels' explicitly or using
## 'multiclass.roc' instead

## Setting levels: control = culture, case = economie

## Setting direction: controls > cases

## Area under the curve: 0.8975

Un Auc de 0.89 a été trouver avec notre jeu de test.

#Visualisation de la prédiction
plot(p3 ~ category, data=testing, xlab="Observe",
       ylab="Predis")

Comparaison modèle

Evaluons nos modèles :

Evaluation du premier modèle :

Matrice de confusion :

prediction_tree <- predict(ArbreChoisi,
             newdata=testing,
           # newdata=test,  
           #trouver un moyen d'utiliser le jeu de test
            type= "class"
           
           )
length(prediction_tree)

## [1] 2000

conf <- confusionMatrix(data=prediction_tree, reference = testing$category)
conf

## Confusion Matrix and Statistics
## 
##            Reference
## Prediction  culture economie planete politique societe sport
##   culture       380       54      49        29      95    55
##   economie       26      223      36        42      87    20
##   planete         4        7      15         4       8     2
##   politique       7       26      11       130      59     1
##   societe        32       51      28        55     287    13
##   sport           7       13       4         5       6   129
## 
## Overall Statistics
##                                         
##                Accuracy : 0.582         
##                  95% CI : (0.56, 0.6037)
##     No Information Rate : 0.271         
##     P-Value [Acc > NIR] : < 2.2e-16     
##                                         
##                   Kappa : 0.4741        
##                                         
##  Mcnemar's Test P-Value : < 2.2e-16     
## 
## Statistics by Class:
## 
##                      Class: culture Class: economie Class: planete
## Sensitivity                  0.8333          0.5963         0.1049
## Specificity                  0.8174          0.8702         0.9865
## Pos Pred Value               0.5740          0.5138         0.3750
## Neg Pred Value               0.9432          0.9036         0.9347
## Prevalence                   0.2280          0.1870         0.0715
## Detection Rate               0.1900          0.1115         0.0075
## Detection Prevalence         0.3310          0.2170         0.0200
## Balanced Accuracy            0.8253          0.7332         0.5457
##                      Class: politique Class: societe Class: sport
## Sensitivity                    0.4906         0.5295       0.5864
## Specificity                    0.9401         0.8772       0.9803
## Pos Pred Value                 0.5556         0.6159       0.7866
## Neg Pred Value                 0.9236         0.8338       0.9504
## Prevalence                     0.1325         0.2710       0.1100
## Detection Rate                 0.0650         0.1435       0.0645
## Detection Prevalence           0.1170         0.2330       0.0820
## Balanced Accuracy              0.7153         0.7034       0.7834

AUC

library(ROCR)
library(pROC)
prediction_tree1 <- predict(ArbreChoisi, newdata=testing, type= "prob")[,1]
length(testing$category)

## [1] 2000

auc(testing$category, prediction_tree1)

## Setting levels: control = culture, case = economie

## Setting direction: controls > cases

## Area under the curve: 0.8919

Un Auc de 0.88 a été obtenu avec notre jeu test.

Visualisation de la prédiction

plot(prediction_tree1 ~ category, data=testing, xlab="Observe",
       ylab="Predis")

Evaluation du deuxième modèle :

Prediction

predict_rf <- predict(modele_rf, newdata=testing, type= "prob")[,1]

Test Prediction

table(predict_rf, testing$category)[1,]

##   culture  economie   planete politique   societe     sport 
##         0         0         0         1         5         2

Fréquence conditionel

table(predict_rf, testing$category)[1:7,]

##           
## predict_rf culture economie planete politique societe sport
##       0          0        0       0         1       5     2
##       0.01       0        1       1         7      12     6
##       0.02       0       15       1        22      15    10
##       0.03       1       13       3        17      23    10
##       0.04       0       15       6        20      33     9
##       0.05       1       20       7        20      36    16
##       0.06       3       27      10        28      36     9

plot(margin(modele_rf, testing$category))

AUC

length(testing$category)

## [1] 2000

auc(testing$category, predict_rf)

## Setting levels: control = culture, case = economie

## Setting direction: controls > cases

## Area under the curve: 0.9254

Un AUC de 0.92 a été obtenu avec notre jeu de test.

#Visualisation de la prédiction
plot(predict_rf ~ category, data=testing, xlab="Observe",
       ylab="Predis")

Mise en œuvre d’un modèle supervisé avec maximum 25 variables

On sélectionne les 25 variables les plus importantes parmis le 2ème modèle (random Forest) Ainsi qu’une visualisation graphique de leur importance.

#class (modele_rf$importance[order(modele_rf$importance[,1], decreasing = TRUE)[1:25], ])
#"matrix" "array" 
modele_rf$importance[order(modele_rf$importance[,1], decreasing = TRUE)[1:25], ]

##              culture      economie       planete     politique       societe
## film      0.03871014  0.0087778459  2.196326e-03  0.0069973624  0.0053405331
## loi       0.03497655  0.0016233037  2.496517e-03  0.0135513325 -0.0015842590
## euros     0.03223901  0.0043517567  6.956789e-04  0.0042480371  0.0025940073
## entrepris 0.03192049  0.0117234220 -2.167049e-04  0.0041045084  0.0030679100
## selon     0.03134683 -0.0035069338 -4.359945e-04  0.0004346854 -0.0035861444
## ministr   0.03024481  0.0113834411  5.111965e-03  0.0054862946 -0.0048195882
## president 0.02427744  0.0012906607 -2.284013e-03  0.0043583319 -0.0023038585
## scen      0.02380558  0.0094921689  2.340883e-03  0.0034388733  0.0032561864
## ete       0.02028520  0.0032765183 -2.338768e-03  0.0009682092 -0.0017347956
## gouvern   0.01942433  0.0034025492  1.054775e-03  0.0082958952 -0.0011399505
## festival  0.01784729  0.0035386310  1.312901e-03  0.0030787980  0.0042334068
## social    0.01702055  0.0010867433  1.802444e-03  0.0084831441 -0.0040597635
## match     0.01691725  0.0070096818  3.108497e-03  0.0038709837  0.0061405835
## art       0.01686848  0.0038070053  2.138072e-04  0.0030030429  0.0048355241
## person    0.01684163 -0.0013589628  3.955570e-04  0.0013059640 -0.0001780602
## contr     0.01624154  0.0030994397 -6.316529e-05  0.0006797415 -0.0034701138
## franc     0.01597043 -0.0005523370 -1.328422e-03  0.0013950682  0.0006594539
## econom    0.01508721  0.0012687154  8.812324e-06  0.0030850817  0.0028498083
## equip     0.01461694  0.0010941108  6.097453e-05  0.0020838198  0.0018765553
## etat      0.01363531 -0.0023594952  5.365671e-04  0.0003371346  0.0005225303
## enquet    0.01264786  0.0032796191  1.373711e-04  0.0029205380  0.0011598476
## salar     0.01231798  0.0007671288 -1.580209e-04  0.0019610318  0.0011450346
## droit     0.01167488  0.0015383518  2.355060e-03  0.0062760487  0.0001085515
## compt     0.01121538 -0.0010141087  2.152671e-04 -0.0002635983 -0.0017559642
## holland   0.01107796  0.0049228919  1.044183e-03  0.0122146090  0.0006020556
##                   sport MeanDecreaseAccuracy MeanDecreaseGini
## film       8.359996e-03          0.013614791        130.56915
## loi        1.406675e-02          0.011052989         51.64602
## euros      6.249172e-03          0.009901256         50.91463
## entrepris  1.240200e-02          0.011789422         66.95609
## selon      6.195701e-03          0.005956638         32.17982
## ministr    1.201055e-02          0.009681025         48.97281
## president  3.054185e-03          0.005663776         32.02559
## scen       4.115294e-03          0.008908070         89.53682
## ete       -7.100280e-04          0.004428161         39.12973
## gouvern    8.796192e-03          0.006690515         37.53740
## festival   2.348666e-03          0.006531865         60.14048
## social     5.388298e-03          0.004630333         31.77249
## match      8.022217e-02          0.015761648        125.82089
## art        4.317349e-03          0.006653271         60.23089
## person     2.354302e-03          0.003914277         26.35765
## contr      2.986584e-03          0.003501412         27.35514
## franc     -5.642474e-03          0.003082647         31.10019
## econom     6.389587e-03          0.005436084         31.76383
## equip      2.083158e-02          0.006399103         40.50759
## etat       3.826048e-03          0.003253022         23.72206
## enquet     3.906319e-03          0.004506333         39.15330
## salar      3.695782e-03          0.003834361         24.76447
## droit      1.616660e-03          0.004070208         25.99186
## compt     -1.694063e-05          0.001765586         16.22222
## holland    5.164951e-03          0.005767989         32.39304

varImpPlot(modele_rf)

 #copie des termes dans l'attente de trouver une méthode pour récup les variables d'une matrice.
# sachant que les mots ne sont pas constant d'une éxécution du code à l'autre
modele_25 = randomForest(category~ selon + film + loi + entrepris + president + ete + ministr + festival + scen + gouvern + contr + franc + match + person + art + general + social + equip + droit + national + etat + final + econom + plac
                         , data=base_modelisation[nb_lignes,],
                         importance = T,
                         proximity=TRUE,
                         ntree = 100)
plot(modele_25)